;;; Lisp

(require 'init-lispy)

(add-hook 'lisp-mode-hook 'ambrevar/turn-on-complete-filename)
(add-hook 'lisp-mode-hook 'ambrevar/turn-on-tab-width-to-8) ; Because some existing code uses tabs.
(add-hook 'lisp-mode-hook 'ambrevar/turn-off-indent-tabs)   ; Should not use tabs.
(add-hook 'lisp-mode-hook 'ambrevar/init-lispy)
(when (fboundp 'rainbow-delimiters-mode)
  (add-hook 'lisp-mode-hook #'rainbow-delimiters-mode))

;; Read CLHS locally.
(or
 ;; Quicklisp package.
 (load "~/.quicklisp/clhs-use-local.el" 'noerror)
 ;; Unofficial Guix package (non-free license).
 (when (require 'clhs nil 'noerror)
   (clhs-setup)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Sly

;; TODO: Report upstream.
;; https://github.com/joaotavora/sly/issues/363
;; REVIEW: This probably works for SLIME too.
(defvar ambrevar/sly-sbcl-core-extra-packages '(:ambrevar))
(defun ambrevar/sly-dump-sbcl-core (&rest extra-package-keywords)
  "Dump an SBCL core optimized for SLY.
EXTRA-PACKAGE-KEYWORDS can be included in the core.
The core is stored in `user-emacs-directory'/sly.
Return path to the generated core, or nil if it failed to generate.
If the core already exists, it's only regenerated if the SBCL version has
changed, of when called interactively."
  (interactive ambrevar/sly-sbcl-core-extra-packages)
  (cl-flet ((read-bytes (path)
                        (with-temp-buffer
                          (insert-file-contents-literally path)
                          (buffer-substring-no-properties (point-min) (point-max))))
            (call-process-to-string (command &rest args)
                                    (with-temp-buffer
                                      (apply #'call-process command nil t nil args)
                                      (buffer-string))))
    (let* ((sbcl-core-dir (expand-file-name "sly/" user-emacs-directory))
           (sbcl-core (expand-file-name "sbcl.core-for-sly" sbcl-core-dir))
           (sbcl-core-version (expand-file-name "sbcl.version" sbcl-core-dir))
           (current-sbcl-version (cadr (split-string
                                        (call-process-to-string "sbcl" "--version"))))
           (lisp-output-buffer (get-buffer-create " *Lisp dump log*")))
      (when (or (called-interactively-p 'any)
                (not (file-exists-p sbcl-core-version))
                (not (version= (car (split-string (read-bytes sbcl-core-version)))
                               current-sbcl-version)))
        (make-directory sbcl-core-dir :parents)
        (with-current-buffer lisp-output-buffer
          (erase-buffer))
        (apply #'call-process
               "sbcl" nil (list lisp-output-buffer t) nil
               "--eval" "(mapc 'require '(sb-bsd-sockets sb-posix sb-introspect sb-cltl2 asdf))"
               (append
                (mapcan (lambda (package-keyword)
                          (list "--eval" (format "(require %S)" package-keyword)))
                        extra-package-keywords)
                (list
                 "--eval" (format "(save-lisp-and-die %S)" sbcl-core)))))
      (if (not (file-exists-p sbcl-core))
          (switch-to-buffer-other-window lisp-output-buffer)
        (with-temp-file sbcl-core-version
          (insert current-sbcl-version))
        sbcl-core))))

(defun ambrevar/helm-ff--shell-interactive-buffer-p (buffer &optional mode)
  (with-current-buffer buffer
    (when (derived-mode-p (or mode 'eshell-mode))
      (let ((next-prompt-fn (cl-case major-mode
                              (sly-mrepl-mode #'comint-next-prompt)
                              (shell-mode #'comint-next-prompt)
                              (eshell-mode #'eshell-next-prompt)
                              (term-mode #'term-next-prompt))))
        (save-excursion
          (goto-char (point-min))
          (funcall next-prompt-fn 1)
          (null (eql (point) (point-min))))))))

(defun ambrevar/helm-ff-shell-alive-p (mode)
  "Returns non nil when a process is running inside `shell-mode' buffer."
  (cl-ecase mode
    (sly-mrepl-mode
     (save-excursion
       (comint-goto-process-mark)
       (or (null comint-last-prompt)
           (not (eql (point)
                     (marker-position (cdr comint-last-prompt)))))))
    (shell-mode
     (save-excursion
       (comint-goto-process-mark)
       (or (null comint-last-prompt)
           (not (eql (point)
                     (marker-position (cdr comint-last-prompt)))))))
    (eshell-mode
     (get-buffer-process (current-buffer)))
    (term-mode
     (save-excursion
       (goto-char (term-process-mark))
       (not (looking-back "\\$ " (- (point) 2)))))))

(with-eval-after-load 'helm-files
  (defun ambrevar/helm-ff-switch-to-shell (_candidate)
    "Like `helm-ff-switch-to-shell' but supports more modes."
    ;; Reproduce the Emacs-25 behavior to be able to edit and send
    ;; command in term buffer.
    (let (term-char-mode-buffer-read-only    ; Emacs-25 behavior.
          term-char-mode-point-at-process-mark ; Emacs-25 behavior.
          (cd-eshell (lambda ()
                       (eshell/cd helm-ff-default-directory)
                       (eshell-reset)))
          (cd-sly (lambda ()            ; XXX: New!
                    (let ((directory helm-ff-default-directory))
                      (sly-change-directory directory)
                      ;; REVIEW: `sly-change-directory' does not change the
                      ;; REPL's dir, do it here.
                      (cd-absolute directory))))
          (cd-shell
           (lambda ()
             (cl-case helm-ff-default-directory)
             (goto-char (point-max))
             (when (eq helm-ff-preferred-shell-mode 'shell-mode)
               (comint-delete-input))
             (insert (format "cd %s"
                             (shell-quote-argument
                              (or (file-remote-p
                                   helm-ff-default-directory 'localname)
                                  helm-ff-default-directory))))
             (cl-case helm-ff-preferred-shell-mode
               (shell-mode (comint-send-input))
               (term-mode (progn (term-char-mode) (term-send-input))))))
          (bufs (cl-loop for b in (mapcar 'buffer-name (buffer-list))
                         when (or
                               (ambrevar/helm-ff--shell-interactive-buffer-p
                                b 'sly-mrepl-mode) ; XXX: New!
                               (helm-ff--shell-interactive-buffer-p
                                b helm-ff-preferred-shell-mode))
                         collect b)))
      ;; Jump to a shell buffer or open a new session.
      (helm-aif (and (not helm-current-prefix-arg)
                     (if (cdr bufs)
                         (helm-comp-read "Switch to shell buffer: " bufs
                                         :must-match t)
                       (car bufs)))
          ;; Display in same window by default to preserve the
          ;; historical behaviour
          (pop-to-buffer it '(display-buffer-same-window))
        (cl-case helm-ff-preferred-shell-mode
          (eshell-mode
           (eshell helm-current-prefix-arg))
          (shell-mode
           (shell (helm-aif (and helm-current-prefix-arg
                                 (prefix-numeric-value
                                  helm-current-prefix-arg))
                      (format "*shell<%s>*" it))))
          (term-mode
           (progn
             (ansi-term (getenv "SHELL")
                        (helm-aif (and helm-current-prefix-arg
                                       (prefix-numeric-value
                                        helm-current-prefix-arg))
                            (format "*ansi-term<%s>*" it)))
             (term-line-mode)))))
      ;; Now cd into directory.
      (helm-aif (and (memq major-mode '(sly-mrepl-mode shell-mode term-mode)) ; XXX: New!
                     (get-buffer-process (current-buffer)))
          (accept-process-output it 0.1))
      (unless (ambrevar/helm-ff-shell-alive-p major-mode) ; XXX: New!
        (funcall
         (cond                          ; XXX: New!
          ((eq major-mode 'eshell-mode)
           cd-eshell)
          ((eq major-mode 'sly-mrepl-mode)
           cd-sly)
          (t
           cd-shell))))))
  (advice-add 'helm-ff-switch-to-shell :override #'ambrevar/helm-ff-switch-to-shell))

(defvar ambrevar/sly-status--last-command-time nil)
(make-variable-buffer-local 'ambrevar/sly-status--last-command-time)
(defun ambrevar/sly-status--record ()
  (setq ambrevar/sly-status--last-command-time (current-time)))

(defun ambrevar/sly-status-formatter (timestamp duration)
  "Return the status display for `ambrevar/sly-status'.
TIMESTAMP is the value returned by `current-time' and DURATION is the floating
time the command took to complete in seconds."
  (format "#[STATUS] End time %s, duration %.3fs\n"
          (format-time-string "%F %T" timestamp)
          duration))

(defcustom ambrevar/sly-status-min-duration 1
  "If a command takes more time than this, display its status with `ambrevar/sly-status'."
  :group 'sly
  :type 'number)

(defun ambrevar/sly-status (&optional formatter min-duration)
  "Termination timestamp and duration of command.
Status is only returned if command duration was longer than
MIN-DURATION \(defaults to `ambrevar/sly-status-min-duration').  FORMATTER
is a function of two arguments, TIMESTAMP and DURATION, that
returns a string."
  (if ambrevar/sly-status--last-command-time
      (let ((duration (time-to-seconds
                       (time-subtract (current-time) ambrevar/sly-status--last-command-time))))
        (setq ambrevar/sly-status--last-command-time nil)
        (if (> duration (or min-duration
                            ambrevar/sly-status-min-duration))
            (funcall (or formatter
                         #'ambrevar/sly-status-formatter)
                     (current-time)
                     duration)
          ""))
    (progn
      (advice-add 'sly-mrepl--send-input-sexp :after #'ambrevar/sly-status--record)
      "")))

(defun ambrevar/sly-prepare-prompt (old-func &rest args)
  (let ((package (nth 0 args))
        (new-prompt (format "%s%s\n%s"
                            (ambrevar/sly-status)
                            (abbreviate-file-name default-directory)
                            (nth 1 args)))
        (error-level (nth 2 args))
        (condition (nth 3 args)))
    (funcall old-func package new-prompt error-level condition)))

(defun ambrevar/sly-mrepl-previous-prompt ()
  "Go to the beginning of the previous REPL prompt."
  (interactive)
  ;; This has two wrinkles around the first prompt: (1) when going to
  ;; the first prompt it leaves point at column 0 (1) when called from
  ;; frist prompt goes to beginning of buffer.  The correct fix is to
  ;; patch comint.el's comint-next-prompt and comint-previous-prompt
  ;; anyway...
  (let* ((inhibit-field-text-motion t)
         (pos (previous-single-char-property-change
               (previous-single-char-property-change (point)
                'sly-mrepl--prompt)
               'sly-mrepl--prompt)))
    (goto-char pos)
    (goto-char (line-beginning-position)))
  (end-of-line))

(defun ambrevar/sly-mrepl-next-prompt ()
  "Go to the beginning of the next REPL prompt."
  (interactive)
  (let ((pos (next-single-char-property-change (line-beginning-position 2)
                                               'sly-mrepl--prompt)))
    (goto-char pos)
    (if (get-text-property (point) 'sly-mrepl--prompt)
        (goto-char (next-single-char-property-change (point)
                                                     'sly-mrepl--prompt))
      (point))))

(with-eval-after-load 'sly
  (advice-add 'sly-mrepl--insert-prompt :around #'ambrevar/sly-prepare-prompt)

  (advice-add 'sly-mrepl-next-prompt :override #'ambrevar/sly-mrepl-next-prompt)
  (advice-add 'sly-mrepl-previous-prompt :override #'ambrevar/sly-mrepl-previous-prompt)

  (setq sly-lisp-implementations
        '((sbcl (lambda ()
                  (let ((core (ambrevar/sly-dump-sbcl-core :ambrevar)))
                    `(("sbcl" ,@(when core `("--core" ,core)))))))
          (ccl ("ccl"))
          (ecl ("ecl"))))

  (with-eval-after-load 'sly-mrepl
    (set-face-attribute 'sly-mrepl-output-face nil :inherit 'default :foreground)
    (setq sly-mrepl-history-file-name (expand-file-name "sly-mrepl-history" user-emacs-directory))
    ;; While `,i RET` is short enough, it's one more key away in Evil insert state:
    (define-key sly-mrepl-mode-map (kbd "C-c M-p") 'sly-mrepl-set-package)
    (define-key sly-mrepl-mode-map (kbd "C-c M-o") 'sly-mrepl-clear-repl))

  (defun ambrevar/sly-load-reload-system ()
    (interactive)
    (funcall
     (if (sly-eval `(slynk-asdf:asdf-system-loaded-p ,(intern (sly-current-package))))
         #'sly-asdf-reload-system
       #'sly-asdf-load-system)
     (intern (sly-current-package))))
  (define-key lisp-mode-map (kbd "<f6>") 'ambrevar/sly-load-reload-system)

  (defun ambrevar/sly-colorize-buffer (str)
    "Useful for colorized output like the tests of Prove."
    (ansi-color-apply str))
  (add-hook 'sly-mrepl-output-filter-functions 'ambrevar/sly-colorize-buffer)

  (defun ambrevar/indent-and-helm-company (arg)
    "Indent then call `helm-company'.
Good substitute for `sly-mrepl-indent-and-complete-symbol'."
    (interactive "P")
    (indent-for-tab-command arg)
    (helm-company))

  (setq sly-command-switch-to-existing-lisp 'always)
  (add-hook 'sly-mrepl-hook #'ambrevar/init-lispy)
  (add-hook 'sly-mrepl-hook #'rainbow-delimiters-mode)
  ;; REVIEW: With Emacs 27 we can:
  ;; (customize-set-variable 'helm-completion-style 'emacs)
  ;; (add-to-list 'completion-styles 'backend)
  (when (require 'helm-sly nil 'noerror)
    ;; (add-hook 'sly-mrepl-hook #'helm-sly-disable-internal-completion)
    ;; REVIEW: Company completion has the benefit of having annotations.
    (when (require 'helm-company nil :noerror)
      (add-hook 'lisp-mode-hook #'company-mode)
      (define-key lisp-mode-map (kbd "<tab>") 'ambrevar/indent-and-helm-company)
      (define-key lisp-mode-map (kbd "M-<tab>") 'ambrevar/indent-and-helm-company)
      (defun ambrevar/sly-set-keys ()
        (define-key sly-mrepl-mode-map (kbd "<tab>") 'ambrevar/indent-and-helm-company)
        (define-key sly-mrepl-mode-map (kbd "M-<tab>") 'ambrevar/indent-and-helm-company))
      (add-hook 'sly-mrepl-hook #'ambrevar/sly-set-keys)
      (add-hook 'sly-mrepl-hook #'company-mode))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SLIME
(defun ambrevar/slime-rainbow-init ()
  (font-lock-mode -1)
  (rainbow-delimiters-mode)
  (font-lock-mode))

(with-eval-after-load 'slime
  ;; REVIEW: Fix issue https://github.com/slime/slime/issues/523:
  ;; Remove with SLIME 2.25.
  (setq slime-defpackage-regexp
        "^(\\(cl:\\|common-lisp:\\|uiop:\\)?\\(defpackage\\|define-package\\)\\>[ \t']*")

  (setq slime-lisp-implementations
        '((sbcl ("sbcl" "--noinform"))
          (ccl ("ccl"))
          (ecl ("ecl"))))
  (let ((slime-extra '(slime-fancy
                       ;; slime-banner
                       slime-mrepl
                       slime-xref-browser
                       ;; slime-highlight-edits ; A bit slow...
                       slime-sprof
                       slime-quicklisp
                       slime-asdf
                       slime-indentation)))
    ;; TODO: Fix slime-repl-ansi-color.
    ;; (when (require 'slime-repl-ansi-color nil t)
    ;;   (add-to-list 'slime-extra 'slime-repl-ansi-color)
    ;;   (setq slime-repl-ansi-color t))

    ;; slime-company should not be `require'd, see
    ;; https://github.com/anwyn/slime-company/issues/11.
    (when (ignore-errors (find-library-name "slime-company"))
      (add-to-list 'slime-extra 'slime-company))
    (define-key slime-editing-map (kbd "C-c C-d C-h") 'slime-documentation-lookup)
    (slime-setup slime-extra)
    (add-hook 'slime-repl-mode-hook 'ambrevar/init-lispy)
    (add-hook 'slime-repl-mode-hook #'ambrevar/slime-rainbow-init)))

(with-eval-after-load 'sly
  (when (require 'helm-sly nil 'noerror)
    (global-helm-sly-mode)
    (add-to-list 'helm-source-names-using-follow "Lisp xrefs"))

  (when (require 'helm-slime nil 'noerror)
    (global-helm-slime-mode)
    (add-to-list 'helm-source-names-using-follow "SLIME xrefs")))

(provide 'init-lisp)
